home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 4 / adb / s-finimp < prev    next >
Text File  |  1996-02-12  |  8KB  |  245 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --    S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N   --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.23 $                             --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Ada.Exceptions;
  37. with Ada.Finalization;
  38. with Ada.Finalization.List_Controller;
  39. with Ada.Unchecked_Conversion;
  40. with System.Storage_Elements;
  41.  
  42. package body System.Finalization_Implementation is
  43.  
  44.    use Ada.Finalization;
  45.    use Ada.Finalization.List_Controller;
  46.    use Ada.Exceptions;
  47.    use System.Finalization_Root;
  48.    use System.Storage_Elements;
  49.  
  50.    --------------------------
  51.    -- Attach_To_Final_List --
  52.    --------------------------
  53.  
  54.    procedure Attach_To_Final_List
  55.      (L   : in out Finalizable_Ptr;
  56.       Obj : in out Finalizable)
  57.    is
  58.       Obj_Ref : constant Finalizable_Ptr := Obj'Unchecked_Access;
  59.    begin
  60.       if L = null then
  61.          Obj.Next := null;
  62.          Obj.Prev := null;
  63.          L        := Obj_Ref;
  64.  
  65.       --  First attachment on a list of dynamically allocated objects. The
  66.       --  access to the list_controller is kept in the PREV of the first
  67.       --  element.
  68.  
  69.       elsif Is_Empty_List_Controller (L)  then
  70.          Obj.Next := null;
  71.          Obj.Prev := L;
  72.          L        := Obj_Ref;
  73.  
  74.       else
  75.          Obj.Next := L;
  76.          Obj.Prev := L.Prev;
  77.          L.Prev   := Obj_Ref;
  78.          L        := Obj_Ref;
  79.       end if;
  80.    end Attach_To_Final_List;
  81.  
  82.    ----------------------------
  83.    -- Detach_From_Final_List --
  84.    ----------------------------
  85.  
  86.    procedure Detach_From_Final_List (Obj : in out Finalizable) is
  87.    begin
  88.  
  89.       if Obj.Prev = null then
  90.  
  91.          null;  -- should not happen
  92.  
  93.       --  when it is the first of a chain of dynamically-allocated object,
  94.       --  L may not be the right pointer since the allocation and the
  95.       --  deallocation can be done with 2 different compatible general
  96.       --  access types
  97.  
  98.       elsif Is_List_Controller (Obj.Prev) then
  99.          Update_List_Controller (Obj.Prev, Obj.Next);
  100.  
  101.       else
  102.          Obj.Prev.Next := Obj.Next;
  103.       end if;
  104.  
  105.       if Obj.Next /= null then
  106.          Obj.Next.Prev := Obj.Prev;
  107.          Obj.Next := null;
  108.       end if;
  109.  
  110.       Obj.Prev := null;
  111.    end Detach_From_Final_List;
  112.  
  113.    -------------------
  114.    -- Finalize_List --
  115.    -------------------
  116.  
  117.    procedure Finalize_List (L : Finalizable_Ptr) is
  118.       P     : Finalizable_Ptr := L;
  119.       Q     : Finalizable_Ptr;
  120.  
  121.    begin
  122.       while P /= null loop
  123.          Q := P.Next;
  124.          Finalize (P.all);
  125.          P := Q;
  126.       end loop;
  127.  
  128.    exception
  129.       when E_Occ : others =>
  130.          Finalize_List (Q);
  131.  
  132.          Raise_Exception (
  133.            E       => Program_Error'Identity,
  134.            Message => "exception "
  135.              & Exception_Name (E_Occ) & " raised during finalization");
  136.    end Finalize_List;
  137.  
  138.    --------------------------
  139.    -- Finalize_Global_List --
  140.    --------------------------
  141.  
  142.    procedure Finalize_Global_List is
  143.    begin
  144.       Finalize_List (Global_Final_List);
  145.    end Finalize_Global_List;
  146.  
  147.    ------------------
  148.    -- Finalize_One --
  149.    ------------------
  150.  
  151.    procedure Finalize_One (Obj : in out  Finalizable) is
  152.    begin
  153.       Detach_From_Final_List (Obj);
  154.       Finalize (Root_Controlled'Class (Obj));
  155.  
  156.    exception
  157.       when E_Occ : others =>
  158.          Raise_Exception (
  159.            E       => Program_Error'Identity,
  160.            Message => "exception "
  161.              & Exception_Name (E_Occ) & " raised during finalization");
  162.    end Finalize_One;
  163.  
  164.    ----------------------------------
  165.    -- Record_Controller Management --
  166.    ----------------------------------
  167.  
  168.    ----------------
  169.    -- Initialize --
  170.    ----------------
  171.  
  172.    procedure Initialize (Object : in out Limited_Record_Controller) is
  173.    begin
  174.       null;
  175.    end Initialize;
  176.  
  177.    procedure Initialize (Object : in out Record_Controller) is
  178.    begin
  179.       Object.My_Address := Object'Address;
  180.    end Initialize;
  181.  
  182.    -------------
  183.    --  Adjust --
  184.    -------------
  185.  
  186.    procedure Adjust (Object : in out Record_Controller) is
  187.  
  188.       My_Offset : constant Storage_Offset
  189.         := Object.My_Address - Object'Address;
  190.  
  191.       P : Finalizable_Ptr;
  192.  
  193.       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
  194.       --  Substract the offset to the pointer
  195.  
  196.       procedure Reverse_Adjust (P : Finalizable_Ptr);
  197.       --  Ajust the components in the reverse order in which they are stored
  198.       --  on the finalization list. (Adjust and Finalization are not done in
  199.       --  the same order)
  200.  
  201.       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
  202.          function To_Addr is
  203.            new Ada.Unchecked_Conversion (Finalizable_Ptr, Address);
  204.  
  205.          function To_Ptr is
  206.            new Ada.Unchecked_Conversion (Address, Finalizable_Ptr);
  207.  
  208.       begin
  209.          if Ptr /= null then
  210.             Ptr := To_Ptr (To_Addr (Ptr) - My_Offset);
  211.          end if;
  212.       end Ptr_Adjust;
  213.  
  214.       procedure Reverse_Adjust (P : Finalizable_Ptr) is
  215.       begin
  216.          if P /= null then
  217.             Ptr_Adjust (P.Next);
  218.             Ptr_Adjust (P.Prev);
  219.             Reverse_Adjust (P.Next);
  220.             Adjust (P.all);
  221.          end if;
  222.       end Reverse_Adjust;
  223.  
  224.    begin
  225.  
  226.       --  Adjust the components and their finalization pointers next
  227.  
  228.       Ptr_Adjust (Object.F);
  229.       Reverse_Adjust (Object.F);
  230.  
  231.       --  then Adjust the object itself
  232.  
  233.       Object.My_Address := Object'Address;
  234.    end Adjust;
  235.  
  236.    --------------
  237.    -- Finalize --
  238.    --------------
  239.  
  240.    procedure Finalize   (Object : in out Limited_Record_Controller) is
  241.    begin
  242.       Finalize_List (Object.F);
  243.    end Finalize;
  244. end System.Finalization_Implementation;
  245.